Baboon mating

Node-links - Association

Photo by Igal Ness on Unsplash

Baboons have the exact physiology as humans do…
— Robert Sapolsky

Ingest

border graph

This dataset contains over 12,000 observations of the following variables:

female_id: three letter “short name” ID for the female in a potentially consorting pair; each female has a unique ID
male_id: three letter “short name” ID for the male in a potentially consorting pair; each male has a unique ID
consort: whether the female-male pair consorted (1) or not (0), given the opportunity to do so
conceptive: whether the estrus cycle resulted in a conception (1) or not (0)

df_path <- "archetypes/baboon-mating/baboon-mating.csv"
df <- read.csv(df_path, header = TRUE, stringsAsFactors = FALSE)
df

Prepare data [Wrangle]

Filtering only a few countries of our interest

df_wrangle <- df %>% select(female_id, male_id, consort, conceptive)
df_wrangle <- filter(df_wrangle, consort == 1)
df_wrangle

df_wrangle <- df_wrangle %>% rename(from='female_id', to='male_id')
df_wrangle

Prepare data [Wrangle]

Format the data into a graph data frame

# Convert data to graph data frame
# directed FALSE means no flow. It's just an association
g <- graph.data.frame(df_wrangle, directed = FALSE)
g

## IGRAPH 31dea47 UN-- 224 1648 -- 
## + attr: name (v/c), consort (e/n), conceptive (e/n)
## + edges from 31dea47 (vertex names):
##  [1] ABB--LUI ABB--LUI ABB--LUI ABB--ZIB ABB--ZIB ABB--ZIB ABB--LUI ABB--ZIB
##  [9] ABB--ZIB ACA--AMO ACA--VAP ACA--AMO ACA--ZIB ACA--LEB ACA--IAG ACA--LEB
## [17] ACA--LOB ACA--ZIB ASH--MLO ASH--VEG ASH--AMA ASH--MLO ASH--EDW ASH--POW
## [25] ASH--POW CAB--ORN CAB--ORN CAB--APO CAB--APO CAI--BLU CAI--EBA CAI--KER
## [33] CAI--TAL CAI--NAF CAI--APO CAI--ORN CAI--APO CAI--OBR CAI--APO CAI--APO
## [41] CAI--EBA CAI--ORN CAI--EBA CHE--GAS CHE--AMI CHE--PLA CHE--GAS CHE--AMI
## [49] CHE--APH CHE--SPY CHE--DEP CHE--DEP CHE--TAL CHE--DEP CHE--NAF CHE--NAF
## [57] CHE--DEP CHE--EXO CHE--DEP CHE--DEP CHE--TAL CHE--EBA CHE--TAL CHE--EBA
## + ... omitted several edges

Prepare data [Wrangle]

Associating different attributes for your Nodes

Creating numerical fields for the Nodes set in order to attribute the nodes size and/or color

## Creating centrality numerical field for the Nodes

# centrality_alpha()
# centrality_authority() 
# centrality_betweenness() 
# centrality_power() 
# centrality_closeness() 
# centrality_eigen() 
# centrality_hub() 
# centrality_pagerank() 
# centrality_subgraph() 
# centrality_degree() 
# centrality_edge_betweenness() 
# centrality_manual() 
# centrality_closeness_harmonic() 
# centrality_closeness_residual() 
# centrality_closeness_generalised() 
# centrality_communicability() 
# centrality_communicability_odd() 
# centrality_communicability_even() 
# centrality_subgraph_odd() 
# centrality_subgraph_even() 
# centrality_katz() 
# centrality_betweenness_network() 
# centrality_betweenness_current() 
# centrality_betweenness_communicability() 
# centrality_betweenness_rsp_simple() 
# centrality_betweenness_rsp_net() 
# centrality_information() 
# centrality_decay() 
# centrality_random_walk() 
# centrality_expected()

df_graph <- g %>% 
    as_tbl_graph() %>% 
    activate(nodes) %>% 
  # associating random numerical value to nodes to differentiate their colors and sizes
    mutate(centrality  = centrality_betweenness())

Prepare data [Wrangle]

Associating different attributes for your Nodes

## Creating group numerical field for the Nodes

# group_components() 
# group_edge_betweenness() 
# group_fast_greedy() 
# group_infomap() 
# group_label_prop() 
# group_leading_eigen() 
# group_louvain() 
# group_optimal() 
# group_spinglass() 
# group_walktrap() 
# group_biconnected_component()

df_graph <- df_graph %>% 
  activate(nodes) %>%
  # use functions to compute numerical values to attribute the edge width and/or color
  mutate(group = group_louvain())

df_graph

## # A tbl_graph: 224 nodes and 1648 edges
## #
## # An undirected multigraph with 1 component
## #
## # Node Data: 224 x 3 (active)
##   name  centrality group
##   <chr>      <dbl> <int>
## 1 ABB         1.61     6
## 2 ACA       347.       6
## 3 ASH        53.4      6
## 4 CAB         2.52     1
## 5 CAI       257.       1
## 6 CHE       792.       1
## # ... with 218 more rows
## #
## # Edge Data: 1,648 x 4
##    from    to consort conceptive
##   <int> <int>   <int>      <int>
## 1     1   115       1          0
## 2     1   115       1          0
## 3     1   115       1          0
## # ... with 1,645 more rows

Associating different attributes for the Edges between Nodes

Creating new numerical fields (smaller values) in order to attribute the edge width and/or color

df_graph <- df_graph %>% 
    activate(edges) %>% 
  # computing random number (n) which are between 0 and 1 to attribute the edge width and/or color
    #mutate(edge_weights = runif(n()))
  ## computes numbers between 0 and 1 according to distance in km
  mutate(edge_weights = conceptive)

df_graph

## # A tbl_graph: 224 nodes and 1648 edges
## #
## # An undirected multigraph with 1 component
## #
## # Edge Data: 1,648 x 5 (active)
##    from    to consort conceptive edge_weights
##   <int> <int>   <int>      <int>        <int>
## 1     1   115       1          0            0
## 2     1   115       1          0            0
## 3     1   115       1          0            0
## 4     1   116       1          0            0
## 5     1   116       1          0            0
## 6     1   116       1          0            0
## # ... with 1,642 more rows
## #
## # Node Data: 224 x 3
##   name  centrality group
##   <chr>      <dbl> <int>
## 1 ABB         1.61     6
## 2 ACA       347.       6
## 3 ASH        53.4      6
## # ... with 221 more rows

Layout & Aesthetic Parameters

Choose the types of Edges you would like to display

# igraph layouts

# bipartite <- create_layout(df_graph, layout = 'igraph', algorithm = 'bipartite')
# circle <- create_layout(df_graph, layout = 'igraph', algorithm = 'circle')
# dh <- create_layout(df_graph, layout = 'igraph', algorithm = 'dh')
# drl <- create_layout(df_graph, layout = 'igraph', algorithm = 'drl')
# fr <- create_layout(df_graph, layout = 'igraph', algorithm = 'fr')
# gem <- create_layout(df_graph, layout = 'igraph', algorithm = 'gem')
# graphopt <- create_layout(df_graph, layout = 'igraph', algorithm = 'graphopt')
# grid <- create_layout(df_graph, layout = 'igraph', algorithm = 'grid')
# kk <- create_layout(df_graph, layout = 'igraph', algorithm = 'kk')
# lgl <- create_layout(df_graph, layout = 'igraph', algorithm = 'lgl')
# mds <- create_layout(df_graph, layout = 'igraph', algorithm = 'mds')
# nicely <- create_layout(df_graph, layout = 'igraph', algorithm = 'nicely')
# sphere <- create_layout(df_graph, layout = 'igraph', algorithm = 'sphere')
# star <- create_layout(df_graph, layout = 'igraph', algorithm = 'star')
# sugiyama <- create_layout(df_graph, layout = 'igraph', algorithm = 'sugiyama')

# ggraph layouts

# backbone <- create_layout(df_graph_undirected, layout = 'backbone')

# centrality_bc <- betweenness(df_graph_directed)
# centrality_cc <- closeness(df_graph_directed)
# centrality <- create_layout(df_graph_undirected, layout = 'centrality', centrality = centrality_bc)

# circlepack <- create_layout(df_graph_directed, layout = 'circlepack')
# dendrogram <- create_layout(df_graph_directed, layout = 'dendrogram')
# eigen <- create_layout(df_graph, layout = 'eigen', type = "laplacian", eigenvector = "smallest")

# fabric <- create_layout(cg, layout = 'fabric')
# focus <- create_layout(df_graph_directed, layout = 'focus', focus = 1)

# hive <- create_layout(df_graph, layout = 'hive', axis = friends, sort.by = degree)

# linear <- create_layout(df_graph, layout = 'linear')
# matrix <- create_layout(df_graph, layout = 'matrix')
# partition <- create_layout(df_graph_directed, layout = 'partition')

# pmds_pivots <- 3
# pmds <- create_layout(df_graph, layout = 'pmds', pivots = pmds_pivots)

stress <- create_layout(df_graph, layout = 'stress')
# sunburst <- create_layout(df_graph_directed, layout = 'partition', circular = TRUE)
# treemap <- create_layout(df_graph_directed, layout = 'treemap')

# df_unrooted <- df_graph_undirected %>%  activate(edges) %>%  mutate(length = runif(n()))
# unrooted <- create_layout(df_graph_undirected, layout = 'unrooted' )

Layout & Aesthetic Parameters

Choose the types of Edges you would like to display

# Edge Types
# geom_edge_arc
# geom_edge_arc0
# geom_edge_arc2
# geom_edge_density
# geom_edge_diagonal
# geom_edge_diagonal0
# geom_edge_diagonal2
# geom_edge_elbow
# geom_edge_elbow0
# geom_edge_elbow2
# geom_edge_fan
# geom_edge_fan0
# geom_edge_fan2
# geom_edge_hive
# geom_edge_hive0
# geom_edge_hive2
# geom_edge_link
# geom_edge_link0
# geom_edge_link2
# geom_edge_loop
# geom_edge_loop0

Plot

nicely

theme_opts <- theme(
    text = element_text(family = "inconsolata"), 
    # plot.margin = unit(c(1.5,1,1,1), "in"),
    legend.position='none'
)

v1 <- ggraph(stress) + 
  geom_edge_link(aes(colour = factor(conceptive))) +
  geom_node_point(aes(color = group, size = centrality)) +
  geom_node_text(aes(label = name)) +
  scale_color_gradient(low = "green", high = "blue", na.value = NA) +
  scale_size(range = c(1,6)) +
  theme_graph()+
  theme_opts

girafe(ggobj = v1, width_svg = 1280/72, height_svg = 720/72,
       options = list(opts_sizing(rescale = TRUE, width = 1.0))
)

References

citations for narrative and data sources

Narrative and Data: Kaggle, Baboon Mating and Conception Probability by Age, https://www.kaggle.com/kinguistics/baboon-mating-and-conception-probability-by-age/data